home *** CD-ROM | disk | FTP | other *** search
/ Gold Medal Software 2 / Gold Medal Software Volume 2 (Gold Medal) (1994).iso / database / bltq18.arj / BB_CIN10.BAS < prev    next >
BASIC Source File  |  1993-08-04  |  14KB  |  491 lines
  1.  
  2. DEFINT A-Z
  3.  
  4. REM $INCLUDE: 'BULLET.BI'
  5. 'bb_cin10.bas 31-May-92 chh
  6. '--example using 8-char key, dups and
  7. '--a second index of LONG INT (on SSN field), dups allowed for this example
  8.  
  9. 'this example shows the transaction-based feature of InsertXB--it purposely
  10. 'adds a record, inserts the first key, and then often times will duplicate
  11. 'an existing SSN key, thus causing the first key and the data record to be
  12. 'removed. The DUPS cnt value displayed is the number of Inserts that were
  13. 'attempted that resulted in a duplicated key being created for the SSN index
  14. 'file.  The DUPS cnt + Records: + IX1 keys: (or + IX2 keys:) should
  15. 'equal the number of records to insert requested (it does). If transaction
  16. 'processing were not available, you would have to go in manually and delete
  17. 'the keys previously added for this record, then remove the record itself
  18. '(physically remove it which is not a function of dBASE). Basically, it'd be
  19. 'a pain if it were even possible at all. With transaction-based routines such
  20. 'as InsertXB, all this is taken care of by BULLET automatically.
  21.  
  22. 'this code is for a simplistic database
  23. 'it uses a single DBF (true DBF-compat) and two related indexes
  24. 'the first index is on the first 5 chars of last name + first char first name
  25. 'second index is on the SSN, since it's a valid LONG INT we use that key type
  26.  
  27. 'C>bc bb_cin10 /o;
  28. 'C>link bb_cin10,,nul,bullet;
  29.  
  30. UseDir$ = ".\"                  'all files use this directory except
  31.                                 'the reindex work file which uses the
  32.                                 'SET TMP= directory or the current directory
  33. CLS
  34. PRINT "BB_CIN10.BAS - 8-CHAR (DUPS) and LONG INT (UNIQUE), InsertXB example"
  35. PRINT "--maintains *2* index files automatically, using NLS sorting."
  36. PRINT ">> USING DIRECTORY "; UseDir$
  37. PRINT
  38.  
  39. TYPE TestRecTYPE
  40. Tag AS STRING * 1
  41. FirstName AS STRING * 15        'a DBF C fieldtype
  42. LastName AS STRING * 19         'C
  43. SSN AS STRING * 9               'N (use C instead to use SUBSTR() on it)
  44. BDate AS STRING * 8             'D
  45. DeptNo AS STRING * 3            'C
  46. Salary AS STRING * 9            'N
  47. END TYPE '64                    'DBF III+ limit is 4000 bytes/128 fields
  48.                                 
  49. DIM DFP AS DOSFilePack
  50. DIM MP AS MemoryPack
  51. DIM IP AS InitPack
  52. DIM EP AS ExitPack
  53. DIM CDP AS CreateDataPack
  54. DIM CKP AS CreateKeyPack
  55. DIM OP AS OpenPack
  56. DIM AP(1 TO 2) AS AccessPack    '2 since we're maintaining 2 index files
  57. DIM SDP AS StatDataPack
  58. DIM SKP AS StatKeyPack
  59.  
  60. DIM FieldList(1 TO 6) AS FieldDescTYPE
  61. DIM TestRec AS TestRecTYPE
  62. DIM ZSTR AS STRING * 1
  63. DIM NameDAT AS STRING * 80      'DBF data file
  64. DIM NameIX1 AS STRING * 80      'first index file
  65. DIM NameIX2 AS STRING * 80      'second index file
  66. DIM KX1 AS STRING * 136         'key expression for first index file
  67. DIM KX2 AS STRING * 136         'key expression for second index file
  68. DIM KeyBuffer AS STRING * 64
  69.  
  70. DIM First$(1 TO 26)
  71. DIM Last$(1 TO 26)
  72. GOSUB FillNamesIn
  73.  
  74. ZSTR = CHR$(0)
  75. NameDAT = UseDir$ + "CHARTEST.DBF" + ZSTR
  76. NameIX1 = UseDir$ + "CHARTEST.IX1" + ZSTR
  77. NameIX2 = UseDir$ + "CHARTEST.IX2" + ZSTR
  78.  
  79. FieldList(1).FieldName = "FIRSTNAME" + ZSTR
  80. FieldList(1).FieldType = "C"
  81. FieldList(1).FieldLength = CHR$(15)
  82. FieldList(1).FieldDC = CHR$(0)
  83. FieldList(2).FieldName = "LASTNAME" + ZSTR + ZSTR
  84. FieldList(2).FieldType = "C"
  85. FieldList(2).FieldLength = CHR$(19)
  86. FieldList(2).FieldDC = CHR$(0)
  87. FieldList(3).FieldName = "SSN" + STRING$(7, 0)
  88. FieldList(3).FieldType = "N"
  89. FieldList(3).FieldLength = CHR$(9)
  90. FieldList(3).FieldDC = CHR$(0)
  91. FieldList(4).FieldName = "BDATE" + STRING$(5, 0)
  92. FieldList(4).FieldType = "D"
  93. FieldList(4).FieldLength = CHR$(8)
  94. FieldList(4).FieldDC = CHR$(0)
  95. FieldList(5).FieldName = "DEPTNO" + STRING$(4, 0)
  96. FieldList(5).FieldType = "C"
  97. FieldList(5).FieldLength = CHR$(3)
  98. FieldList(5).FieldDC = CHR$(0)
  99. FieldList(6).FieldName = "SALARY" + STRING$(4, 0)
  100. FieldList(6).FieldType = "N"
  101. FieldList(6).FieldLength = CHR$(9)
  102. FieldList(6).FieldDC = CHR$(2)
  103.  
  104. level = 100
  105. MP.Func = MemoryXB
  106. stat = BULLET(MP)
  107. IF MP.Memory < 140000 THEN
  108.     QBheap& = SETMEM(-150000)       'hog wild, 64K would do okay
  109.     MP.Func = MemoryXB
  110.     stat = BULLET(MP)
  111.     IF MP.Memory < 140000 THEN stat = 8: GOTO Abend
  112. END IF
  113.  
  114. level = 110
  115. IP.Func = InitXB
  116. IP.JFTmode = 0
  117. stat = BULLET(IP)
  118. IF stat THEN GOTO Abend
  119.  
  120. level = 120
  121. EP.Func = AtExitXB
  122. stat = BULLET(EP)
  123.  
  124. level = 130
  125. DFP.Func = DeleteFileDOS
  126. DFP.FilenamePtrOff = VARPTR(NameDAT)
  127. DFP.FilenamePtrSeg = VARSEG(NameDAT)
  128. stat = BULLET(DFP)
  129. DFP.FilenamePtrOff = VARPTR(NameIX1)
  130. DFP.FilenamePtrSeg = VARSEG(NameIX1)
  131. stat = BULLET(DFP)
  132. DFP.FilenamePtrOff = VARPTR(NameIX2)
  133. DFP.FilenamePtrSeg = VARSEG(NameIX2)
  134. stat = BULLET(DFP)
  135.  
  136. level = 1000
  137. CDP.Func = CreateDXB
  138. CDP.FilenamePtrOff = VARPTR(NameDAT)
  139. CDP.FilenamePtrSeg = VARSEG(NameDAT)
  140. CDP.NoFields = 6
  141. CDP.FieldListPtrOff = VARPTR(FieldList(1))
  142. CDP.FieldListPtrSeg = VARSEG(FieldList(1))
  143. CDP.FileID = 3
  144. stat = BULLET(CDP)
  145. IF stat THEN GOTO Abend
  146.  
  147. level = 1010
  148. OP.Func = OpenDXB
  149. OP.FilenamePtrOff = VARPTR(NameDAT)
  150. OP.FilenamePtrSeg = VARSEG(NameDAT)
  151. OP.ASmode = ReadWrite + DenyNone
  152. stat = BULLET(OP)
  153. IF stat THEN GOTO Abend
  154. HandDAT = OP.Handle
  155.  
  156. level = 1100
  157. KX1 = "SUBSTR(LASTNAME,1,5)+SUBSTR(FIRSTNAME,1,1)"
  158. CKP.Func = CreateKXB
  159. CKP.FilenamePtrOff = VARPTR(NameIX1)
  160. CKP.FilenamePtrSeg = VARSEG(NameIX1)
  161. CKP.KeyExpPtrOff = VARPTR(KX1)
  162. CKP.KeyExpPtrSeg = VARSEG(KX1)
  163. CKP.XBlink = HandDAT
  164. CKP.KeyFlags = cCHAR
  165. CKP.CodePageID = -1
  166. CKP.CountryCode = -1
  167. CKP.CollatePtrOff = 0
  168. CKP.CollatePtrSeg = 0
  169. stat = BULLET(CKP)
  170. IF stat THEN GOTO Abend
  171.  
  172. level = 1102
  173. KX2 = "SSN"
  174. CKP.Func = CreateKXB
  175. CKP.FilenamePtrOff = VARPTR(NameIX2)
  176. CKP.FilenamePtrSeg = VARSEG(NameIX2)
  177. CKP.KeyExpPtrOff = VARPTR(KX2)
  178. CKP.KeyExpPtrSeg = VARSEG(KX2)
  179. CKP.XBlink = HandDAT
  180. CKP.KeyFlags = cLONG + cUNIQUE          'test transaction ability by forcing
  181. CKP.CodePageID = -1                     'duplicate SSN numbers
  182. CKP.CountryCode = -1                    'number of final records and keys in
  183. CKP.CollatePtrOff = 0                   'each index file should be number of
  184. CKP.CollatePtrSeg = 0                   'Inserts requested - DUPS cnt
  185. stat = BULLET(CKP)
  186. IF stat THEN GOTO Abend
  187.  
  188. level = 1110
  189. OP.Func = OpenKXB
  190. OP.FilenamePtrOff = VARPTR(NameIX1)
  191. OP.FilenamePtrSeg = VARSEG(NameIX1)
  192. OP.ASmode = ReadWrite + DenyNone
  193. OP.xbHandle = HandDAT
  194. stat = BULLET(OP)
  195. IF stat THEN GOTO Abend
  196. HandIX1 = OP.Handle
  197.  
  198. level = 1112
  199. OP.Func = OpenKXB
  200. OP.FilenamePtrOff = VARPTR(NameIX2)
  201. OP.FilenamePtrSeg = VARSEG(NameIX2)
  202. OP.ASmode = ReadWrite + DenyNone
  203. OP.xbHandle = HandDAT
  204. stat = BULLET(OP)
  205. IF stat THEN GOTO Abend
  206. HandIX2 = OP.Handle
  207.  
  208. AP(1).Func = InsertXB
  209. AP(1).Handle = HandIX1
  210. AP(1).RecPtrOff = VARPTR(TestRec)
  211. AP(1).RecPtrSeg = VARSEG(TestRec)
  212. AP(1).KeyPtrOff = VARPTR(KeyBuffer)
  213. AP(1).KeyPtrSeg = VARSEG(KeyBuffer)
  214. AP(1).NextPtrOff = VARPTR(AP(2))
  215. AP(1).NextPtrSeg = VARSEG(AP(2))
  216. AP(2).Func = InsertXB
  217. AP(2).Handle = HandIX2
  218. AP(2).RecPtrOff = VARPTR(TestRec)
  219. AP(2).RecPtrSeg = VARSEG(TestRec)
  220. AP(2).KeyPtrOff = VARPTR(KeyBuffer)
  221. AP(2).KeyPtrSeg = VARSEG(KeyBuffer)
  222. AP(2).NextPtrOff = 0
  223. AP(2).NextPtrSeg = 0
  224.  
  225. level = 1200
  226. 'keep Recs to insert below 1000 since there SSN values generated in this
  227. 'example range from 100000000 to 1000000999
  228.  
  229. INPUT "(suggest no more than 1000) Recs to insert:"; Recs2Add&
  230. PRINT "Inserting record:";
  231. herecol = POS(0)
  232.  
  233. 'these are not key values so just make them constant for this example
  234.  
  235. TestRec.Tag = " "
  236. TestRec.BDate = "19331122"   'yes, everyone is the same age
  237. TestRec.DeptNo = "001"       'yes, same dept too
  238. TestRec.Salary = "125000.77" 'and even the same salary
  239.  
  240. 'RANDOMIZE TIMER
  241. GOSUB StartTimer
  242. FOR Recs& = 1 TO Recs2Add&
  243.    RandLN = 1 + (25 * RND)
  244.    RandFN = 1 + (25 * RND)
  245.    TestRec.FirstName = First$(RandLN)
  246.    TestRec.LastName = Last$(RandFN)
  247.    TestRec.SSN = LTRIM$(STR$(100000000 + (999 * RND)))  'make it easy to DUP
  248.    stat = 0
  249.    LOCATE , herecol
  250.    PRINT Recs&;
  251.    sidx = BULLET(AP(1))
  252.    IF sidx = 0 AND AP(1).stat THEN
  253.       'error on data record add portion of insert
  254.       stat = AP(1).stat
  255.       GOTO Abend                        'consider this a fatal error
  256.    ELSEIF sidx THEN
  257.       stat = AP(sidx).stat
  258.       IF stat <> 201 THEN
  259.          GOTO Abend                     'this too
  260.       ELSE  'key already exists test    'a key already exists just skip
  261.          dups = dups + 1                'for this example--it backs out the
  262.          PRINT "   SSN dups/Inserts backed-out:"; dups;
  263.       END IF                            'added record and previous key insert,
  264.    END IF                               'if any for this record was inserted
  265. NEXT
  266. GOSUB EndTimer
  267. LOCATE , 55
  268. PRINT "..."; secs&; "secs."
  269. PRINT
  270. PRINT "DUPS cnt="; dups;
  271. GOSUB ShowStats
  272.  
  273. level = 1300
  274. AP(1).Func = GetFirstXB
  275. stat = BULLET(AP(1))
  276. PRINT
  277. PRINT "Using key expression: "; RTRIM$(KX1); " dups allowed"
  278. PRINT
  279. PRINT "...the first 5 keys/recs for first index file "
  280. CIX = 1: GOSUB DispRecord
  281. FOR i = 1 TO 4
  282.    IF stat THEN EXIT FOR
  283.    AP(1).Func = GetNextXB
  284.    stat = BULLET(AP(1))
  285.    GOSUB DispRecord
  286. NEXT
  287. IF stat = 202 THEN stat = 0
  288. IF stat THEN GOTO Abend
  289. PRINT
  290.  
  291. level = 1310
  292. AP(1).Func = GetLastXB
  293. stat = BULLET(AP(1))
  294. PRINT "...the last 5 keys/recs for first index file "
  295. CIX = 1: GOSUB DispRecord
  296. FOR i = 1 TO 4
  297.    IF stat THEN EXIT FOR
  298.    AP(1).Func = GetPrevXB
  299.    stat = BULLET(AP(1))
  300.    GOSUB DispRecord
  301. NEXT
  302. IF stat THEN GOTO Abend
  303. PRINT
  304. PRINT "* Press any key to see first/last 5 for SECOND index file";
  305. DO: LOOP UNTIL LEN(INKEY$)
  306. LOCATE , 1
  307.  
  308. level = 1302
  309. AP(2).Func = GetFirstXB
  310. stat = BULLET(AP(2))
  311. PRINT SPACE$(79);
  312. LOCATE , 1
  313. PRINT "Using key expression: "; RTRIM$(KX2); ", UNIQUE keys only"
  314. PRINT
  315. PRINT "...the first 5 keys/recs for second index file "
  316. CIX = 2: GOSUB DispRecord
  317. FOR i = 1 TO 4
  318.    IF stat THEN EXIT FOR
  319.    AP(2).Func = GetNextXB
  320.    stat = BULLET(AP(2))
  321.    GOSUB DispRecord
  322. NEXT
  323. IF stat = 202 THEN stat = 0
  324. IF stat THEN GOTO Abend
  325. PRINT
  326.  
  327. level = 1312
  328. AP(2).Func = GetLastXB
  329. stat = BULLET(AP(2))
  330. PRINT "...the last 5 keys/recs for second index file "
  331. CIX = 2: GOSUB DispRecord
  332. FOR i = 1 TO 4
  333.    IF stat THEN EXIT FOR
  334.    AP(2).Func = GetPrevXB
  335.    stat = BULLET(AP(2))
  336.    GOSUB DispRecord
  337. NEXT
  338. IF stat THEN GOTO Abend
  339.  
  340. PRINT "Okay."
  341. EndIt:
  342. EP.Func = ExitXB
  343. stat = BULLET(EP)
  344. END
  345.  
  346.  
  347. Abend:
  348. PRINT
  349. PRINT "Error:"; stat; "at level"; level; "while performing ";
  350. SELECT CASE level
  351. CASE IS = 999
  352.    SELECT CASE level
  353.    CASE 100
  354.       PRINT "a memory request of 150K."
  355.    CASE 110
  356.       PRINT "BULLET initialization."
  357.    CASE 120
  358.       PRINT "registering of ExitXB with _atexit."
  359.    CASE ELSE
  360.       PRINT "Preliminaries unknown."
  361.    END SELECT
  362. CASE IS <= 1099
  363.    SELECT CASE level
  364.    CASE 1000
  365.       PRINT "data file create."
  366.    CASE 1010
  367.       PRINT "data file open."
  368.    CASE ELSE
  369.       PRINT "data file unknown."
  370.    END SELECT
  371. CASE IS <= 1199
  372.    SELECT CASE level
  373.    CASE 1100
  374.       PRINT "first index file create."
  375.    CASE 1102
  376.       PRINT "second index file create."
  377.    CASE 1110
  378.       PRINT "first index file open."
  379.    CASE 1112
  380.       PRINT "second index file open."
  381.    CASE ELSE
  382.       PRINT "index file unknown."
  383.    END SELECT
  384. CASE IS <= 1299
  385.    SELECT CASE level
  386.    CASE 1200
  387.       PRINT "inserting records."
  388.    CASE ELSE
  389.       PRINT "adding unknown."
  390.    END SELECT
  391. CASE IS <= 1399
  392.    SELECT CASE level
  393.    CASE 1300
  394.       PRINT "first index file GetFirst/Next."
  395.    CASE 1302
  396.       PRINT "second index file GetFirst/Next."
  397.    CASE 1310
  398.       PRINT "first index file GetLast/Prev."
  399.    CASE 1312
  400.       PRINT "second index file GetLast/Prev."
  401.    CASE ELSE
  402.       PRINT "Get/unknown."
  403.    END SELECT
  404. CASE ELSE
  405.    PRINT "unknown."
  406. END SELECT
  407. GOTO EndIt
  408.  
  409. '----------
  410. ShowStats:
  411. SDP.Func = StatDXB
  412. SDP.Handle = HandDAT
  413. stat = BULLET(SDP)
  414. IF stat = 0 THEN
  415.    PRINT "Records:"; SDP.Recs;
  416.    SKP.Func = StatKXB
  417.    SKP.Handle = HandIX1
  418.    stat = BULLET(SKP)
  419.    IF stat = 0 THEN
  420.       PRINT " IX1:keys:"; SKP.Keys;
  421.       SKP.Func = StatKXB
  422.       SKP.Handle = HandIX2
  423.       stat = BULLET(SKP)
  424.       IF stat = 0 THEN
  425.          PRINT " IX2:keys:"; SKP.Keys
  426.       ELSE
  427.          PRINT "*IX2:StatKXB"; stat
  428.       END IF
  429.    ELSE
  430.       PRINT "*IX1:StatKXB"; stat
  431.    END IF
  432. ELSE
  433.    PRINT "*DBF:StatDXB"; stat
  434. END IF
  435. RETURN
  436.  
  437. DispRecord:
  438. t$ = SPACE$(79)
  439. MID$(t$, 1, 6) = RIGHT$("     " + LTRIM$(STR$(AP(CIX).Recno)), 6)
  440. MID$(t$, 7, 1) = TestRec.Tag
  441. t2$ = RTRIM$(TestRec.LastName) + ", " + RTRIM$(TestRec.FirstName)
  442. MID$(t$, 8, 30) = t2$
  443. t2$ = MID$(TestRec.SSN, 1, 3) + "-" + MID$(TestRec.SSN, 4, 2) + "-" + MID$(TestRec.SSN, 6, 4)
  444. MID$(t$, 40, 11) = t2$
  445. t2$ = MID$(TestRec.BDate, 5, 2) + "/" + MID$(TestRec.BDate, 7, 2) + "/" + MID$(TestRec.BDate, 3, 2)
  446. MID$(t$, 53, 8) = t2$
  447. MID$(t$, 63, 3) = TestRec.DeptNo
  448. MID$(t$, 68, 9) = TestRec.Salary
  449. PRINT t$
  450. RETURN
  451.  
  452. StartTimer:
  453. DEF SEG = &H40
  454. lb1 = PEEK(&H6C)
  455. hb1 = PEEK(&H6D)
  456. lb2 = PEEK(&H6E)
  457. DEF SEG
  458. stime& = CVL(CHR$(lb1) + CHR$(hb1) + CHR$(lb2) + ZSTR)
  459. RETURN
  460.  
  461. EndTimer:
  462. DEF SEG = &H40
  463. lb1 = PEEK(&H6C)
  464. hb1 = PEEK(&H6D)
  465. lb2 = PEEK(&H6E)
  466. DEF SEG
  467. etime& = CVL(CHR$(lb1) + CHR$(hb1) + CHR$(lb2) + ZSTR)
  468. secs& = ((etime& - stime&) * 10) \ 182
  469. RETURN
  470.  
  471. FillNamesIn:
  472. FOR i = 1 TO 26
  473.    READ F$
  474.    First$(i) = F$ + SPACE$(15)  'space-fill names
  475. NEXT
  476. FOR i = 1 TO 26
  477.    READ L$
  478.    Last$(i) = L$ + SPACE$(19)
  479. NEXT
  480. RETURN
  481.  
  482. DATA "Arturo","Bebe","Clarisa","Diamond","Eve","Franklin","Gweny","Horatio"
  483. DATA "Iggie","Jammal","Kevin","Legs","Michelle","Nova","Obar","Pepi","Quartz"
  484. DATA "Raul","Santa","Thomas","Uve","Vue","Winchester","Xeba","Yve","Zanzi"
  485.  
  486. DATA "Abelson","ABELSON","Charlieson","Deltason","Epsilson","Foxson","Gamson","Hydra"
  487. DATA "Manson","Jumpson","Kiloson","Loxson", "Moonson","Noson","Octson"
  488. DATA "Pepson","Quarterson","Renoson","Salvoson","Tooson","Underson","Vulcanson"
  489. DATA "Weaverson","Xanson","ZENDASON","Zendason"
  490.  
  491.